-- card: 2103 from stack: in.3 -- bmap block id: 0 -- flags: 4000 -- background id: 3241 -- name: ClipToPICT ----- HyperTalk script ----- on Install get ChooseTargetStack() InstallResource XFCN,ClipToPICT,it end Install -- part 1 (button) -- low flags: 00 -- high flags: A003 -- rect: left=75 top=300 right=322 bottom=192 -- title width / last selected line: 0 -- icon id / first selected line: 0 / 0 -- text alignment: 1 -- font id: 0 -- text size: 12 -- style flags: 0 -- line height: 16 -- part name: ClipToPICT ----- HyperTalk script ----- on mouseUp put ClipToPICT() end mouseUp -- part 2 (field) -- low flags: 81 -- high flags: 2007 -- rect: left=12 top=26 right=298 bottom=491 -- title width / last selected line: 0 -- icon id / first selected line: 0 / 0 -- text alignment: 0 -- font id: 22 -- text size: 10 -- style flags: 0 -- line height: 13 -- part name: Source -- part 4 (button) -- low flags: 00 -- high flags: A003 -- rect: left=299 top=300 right=322 bottom=438 -- title width / last selected line: 0 -- icon id / first selected line: 0 / 0 -- text alignment: 1 -- font id: 0 -- text size: 12 -- style flags: 0 -- line height: 16 -- part name: Show Pascal Source ----- HyperTalk script ----- on mouseUp set the visible of card field 1 to not the visible of card field 1 if the visible of card field 1 is true then set the name of me to "Hide Pascal Source" else set the name of me to "Show Pascal Source" end mouseUp -- part contents for background part 16 ----- text ----- CLIPTOPICT XFCN version 1.6 Kevin Calhoun ClipToPICT creates a PICT resource from a picture you've copied to the clipboard and copies it to the current stack. You can tell ClipToPICT what ID number you want the PICT resource to have or you can let it select an unused number for you. If you choose a number that belongs to another PICT resource currently contained in your stack, the new picture will overwrite the old one. You'll know when there's a picture on the clipboard by examining HyperCard's edit menu. If the paste item says "Paste Picture," then there's a picture available for ClipToPICT to turn into a PICT resource. As with other resource copiers, if you use ClipToPICT to copy a PICT into the Home stack, you may have to quit and relaunch HyperCard in order to use it. INVOKING CLIPTOPICT get ClipToPICT(,<"pictName">) result: resourceID Both parameters are optional. If you don't pass a value for pictID, ClipToPICT will find an ID for the PICT resource that's not currently in use. If you don't pass a value for pictName, the PICT resource will be unnamed. If you pass a value for pictID or pictName that's already in use by another PICT resource in the current stack, the old PICT will be overwritten. If the clipboard contains no pictures, or if there was a problem accessing the scrap, opening the current stack's resource file, or writing the resource, ClipToPICT will return an error message. Word 1 of this message will be "Error." EXAMPLES put ClipToPICT(0,"The Little Engine That Could") into pictNumber get ClipToPICT(2880,"") REVISION HISTORY 1.0 -- 4/22/88 1.5 -- 3/15/89 Altered source code for compatibility with MPW Pascal 3.0. Also removed necessity of passing 0 as the PICT ID when you wanted ClipToPICT to select an unused ID. 1.6 -- 7/22/89 No longer leaves a NIL master pointer behind when replacing a resource. -- part contents for card part 2 ----- text ----- UNIT ClipToPICTUnit; { ClipToPICT XFCN © 1988-1989 by the Trustees of Dartmouth College } { Written by Kevin Calhoun } { This source compatible with MPW Pascal 3.0 } (* Pascal ClipToPICT.p Link -m ENTRYPOINT ∂ -o "YourFile" ∂ -rt XFCN=6465 ∂ -sn Main=ClipToPICT ∂ ClipToPICT.p.o ∂ "{Libraries}"interface.o ∂ "{PLibraries}"Paslib.o ∂ "{Libraries}"HyperXLib.o *) {$R-} INTERFACE USES Types, Memory, Scrap, ToolUtils, Resources, Errors, HyperXCmd; PROCEDURE EntryPoint (paramPtr : XCMDPtr); IMPLEMENTATION PROCEDURE GetPictScrap (paramPtr : XCMDPtr); FORWARD; PROCEDURE EntryPoint (paramPtr : XCMDPtr); BEGIN GetPictScrap(paramPtr); END; FUNCTION GetTheNameOfThisStack (paramPtr : XCMDPtr; var str: Str255): OSErr; VAR theResult : Handle; theLength : Longint; err: OSErr; BEGIN err := noErr; str := 'word 2 of the long name of this stack'; theResult := EvalExpr(paramPtr, str); err := paramPtr^.result; IF (theResult <> NIL) and (err = noErr) THEN BEGIN theLength := StringLength(paramPtr, theResult^); ZeroToPas(paramPtr, theResult^, str); DisposHandle(theResult); DELETE(str,theLength,1); DELETE(str,1,1); END ELSE str := ''; GetTheNameOfThisStack := err; END; PROCEDURE GetPictScrap (paramPtr : XCMDPtr); LABEL 99, 100; VAR parameterCount : INTEGER; id : INTEGER; name : Str255; scrapLength : longint; offset : longint; thePicHandle : Handle; str : Str255; myStack, curFile : INTEGER; resAlready : Handle; gotID, gotName : BOOLEAN; err: LONGINT; PROCEDURE PassReturnValue (theMsg : Str255); { set theResult and quit } BEGIN paramPtr^.returnValue := PasToZero(paramPtr, theMsg); END; PROCEDURE GetParameters; BEGIN gotID := FALSE; gotName := FALSE; name := ''; IF parameterCount > 0 THEN BEGIN ZeroToPas(paramPtr, paramPtr^.params[1]^, str); if LENGTH(str) > 0 THEN gotID := TRUE; id := StrToNum(paramPtr, str); IF parameterCount > 1 THEN BEGIN ZeroToPas(paramPtr, paramPtr^.params[2]^, name); if LENGTH(name) > 0 THEN gotName := TRUE; END; END; END; PROCEDURE CheckForSameTypeIDName; BEGIN SetResLoad(FALSE); IF not gotID THEN REPEAT id := Unique1ID('PICT'); UNTIL id > 127 ELSE REPEAT resAlready := Get1Resource('PICT', id); IF resAlready <> NIL THEN BEGIN RmveResource(resAlready); DisposHandle(resAlready); END; UNTIL resAlready = NIL; IF gotName THEN REPEAT resAlready := Get1NamedResource('PICT', name); IF resAlready <> NIL THEN BEGIN RmveResource(resAlready); DisposHandle(resAlready); END; UNTIL resAlready = NIL; SetResLoad(TRUE); END; BEGIN err := noErr; parameterCount := paramPtr^.paramCount; IF parameterCount > 2 THEN PassReturnValue('ClipToPICT XFCN 1.6, 22 July 1989, ©1988-1989 Dartmouth College') ELSE BEGIN GetParameters; err := GetTheNameOfThisStack(paramPtr,str); IF err <> noErr THEN GOTO 100; myStack := OpenResFile(str); IF (myStack = -1) AND (ResError = eofErr) THEN BEGIN CreateResFile(str); err := ResError; IF err = noErr THEN myStack := OpenResFile(str); END; IF (myStack <= 0) OR (err <> noErr) THEN GOTO 100; scrapLength := GetScrap(NIL, 'PICT', offset); IF scrapLength < 0 THEN BEGIN err := scrapLength; GOTO 100; END; thePicHandle := NewHandle(0); err := MemError; IF (thePicHandle = NIL) or (err <> noErr) THEN GOTO 100; scrapLength := GetScrap(thePicHandle, 'PICT', offset); IF scrapLength <= 0 THEN BEGIN err := scrapLength; GOTO 99; END; HNoPurge(thePicHandle); curFile := CurResFile; UseResFile(myStack); CheckForSameTypeIDName; AddResource(thePicHandle, 'PICT', id, name); err := ResError; IF err <> noErr THEN BEGIN DisposHandle(thePicHandle); GOTO 99; END; SetResAttrs(thePicHandle, resPurgeable + resChanged); WriteResource(thePicHandle); UpdateResFile(myStack); ReleaseResource(thePicHandle); NumToStr(paramPtr, id, str); PassReturnValue(str); 99: UseResFile(curFile); 100: IF err <> noErr THEN BEGIN NumToStr(paramPtr, err, str); PassReturnValue(CONCAT('Error ', str)); END; END; END; END.